home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclBinary.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  22.8 KB  |  982 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclBinary.c --
  3.  *
  4.  *    This file contains the implementation of the "binary" Tcl built-in
  5.  *    command .
  6.  *
  7.  * Copyright (c) 1997 by Sun Microsystems, Inc.
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  *
  12.  * SCCS: @(#) tclBinary.c 1.20 97/08/11 18:43:09
  13.  */
  14.  
  15. #include <math.h>
  16. #include "tclInt.h"
  17. #include "tclPort.h"
  18.  
  19. /*
  20.  * The following constants are used by GetFormatSpec to indicate various
  21.  * special conditions in the parsing of a format specifier.
  22.  */
  23.  
  24. #define BINARY_ALL -1        /* Use all elements in the argument. */
  25. #define BINARY_NOCOUNT -2    /* No count was specified in format. */
  26.  
  27. /*
  28.  * Prototypes for local procedures defined in this file:
  29.  */
  30.  
  31. static int        GetFormatSpec _ANSI_ARGS_((char **formatPtr,
  32.                 char *cmdPtr, int *countPtr));
  33. static int        FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
  34.                 Tcl_Obj *src, char **cursorPtr));
  35. static Tcl_Obj *    ScanNumber _ANSI_ARGS_((char *buffer, int type));
  36.  
  37. /*
  38.  *----------------------------------------------------------------------
  39.  *
  40.  * Tcl_BinaryObjCmd --
  41.  *
  42.  *    This procedure implements the "binary" Tcl command.
  43.  *
  44.  * Results:
  45.  *    A standard Tcl result.
  46.  *
  47.  * Side effects:
  48.  *    See the user documentation.
  49.  *
  50.  *----------------------------------------------------------------------
  51.  */
  52.  
  53. int
  54. Tcl_BinaryObjCmd(dummy, interp, objc, objv)
  55.     ClientData dummy;        /* Not used. */
  56.     Tcl_Interp *interp;        /* Current interpreter. */
  57.     int objc;            /* Number of arguments. */
  58.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  59. {
  60.     int arg;            /* Index of next argument to consume. */
  61.     int value = 0;        /* Current integer value to be packed.
  62.                  * Initialized to avoid compiler warning. */
  63.     char cmd;            /* Current format character. */
  64.     int count;            /* Count associated with current format
  65.                  * character. */
  66.     char *format;        /* Pointer to current position in format
  67.                  * string. */
  68.     char *cursor;        /* Current position within result buffer. */
  69.     char *maxPos;        /* Greatest position within result buffer that
  70.                  * cursor has visited.*/
  71.     char *buffer;        /* Start of data buffer. */
  72.     char *errorString, *errorValue, *str;
  73.     int offset, size, length;
  74.     Tcl_Obj *resultPtr;
  75.     
  76.     static char *subCmds[] = { "format", "scan", (char *) NULL };
  77.     enum { BinaryFormat, BinaryScan } index;
  78.  
  79.     if (objc < 2) {
  80.         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
  81.     return TCL_ERROR;
  82.     }
  83.  
  84.     if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
  85.         (int *) &index) != TCL_OK) {
  86.         return TCL_ERROR;
  87.     }
  88.  
  89.     switch (index) {
  90.     case BinaryFormat:
  91.         if (objc < 3) {
  92.         Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
  93.         return TCL_ERROR;
  94.         }
  95.         /*
  96.          * To avoid copying the data, we format the string in two passes.
  97.          * The first pass computes the size of the output buffer.  The
  98.          * second pass places the formatted data into the buffer.
  99.          */
  100.  
  101.         format = Tcl_GetStringFromObj(objv[2], NULL);
  102.         arg = 3;
  103.         offset = length = 0;
  104.         while (*format != 0) {
  105.         if (!GetFormatSpec(&format, &cmd, &count)) {
  106.             break;
  107.         }
  108.         switch (cmd) {
  109.             case 'a':
  110.             case 'A':
  111.             case 'b':
  112.             case 'B':
  113.             case 'h':
  114.             case 'H':
  115.             /*
  116.              * For string-type specifiers, the count corresponds
  117.              * to the number of characters in a single argument.
  118.              */
  119.  
  120.             if (arg >= objc) {
  121.                 goto badIndex;
  122.             }
  123.             if (count == BINARY_ALL) {
  124.                 (void)Tcl_GetStringFromObj(objv[arg], &count);
  125.             } else if (count == BINARY_NOCOUNT) {
  126.                 count = 1;
  127.             }
  128.             arg++;
  129.             if (cmd == 'a' || cmd == 'A') {
  130.                 offset += count;
  131.             } else if (cmd == 'b' || cmd == 'B') {
  132.                 offset += (count + 7) / 8;
  133.             } else {
  134.                 offset += (count + 1) / 2;
  135.             }
  136.             break;
  137.  
  138.             case 'c':
  139.             size = 1;
  140.             goto doNumbers;
  141.             case 's':
  142.             case 'S':
  143.             size = 2;
  144.             goto doNumbers;
  145.             case 'i':
  146.             case 'I':
  147.             size = 4;
  148.             goto doNumbers;
  149.             case 'f':
  150.             size = sizeof(float);
  151.             goto doNumbers;
  152.             case 'd':
  153.             size = sizeof(double);
  154.             doNumbers:
  155.             if (arg >= objc) {
  156.                 goto badIndex;
  157.             }
  158.  
  159.             /*
  160.              * For number-type specifiers, the count corresponds
  161.              * to the number of elements in the list stored in
  162.              * a single argument.  If no count is specified, then
  163.              * the argument is taken as a single non-list value.
  164.              */
  165.  
  166.             if (count == BINARY_NOCOUNT) {
  167.                 arg++;
  168.                 count = 1;
  169.             } else {
  170.                 int listc;
  171.                 Tcl_Obj **listv;
  172.                 if (Tcl_ListObjGetElements(interp, objv[arg++],
  173.                     &listc, &listv) != TCL_OK) {
  174.                 return TCL_ERROR;
  175.                 }
  176.                 if (count == BINARY_ALL) {
  177.                 count = listc;
  178.                 } else if (count > listc) {
  179.                 errorString = "number of elements in list does not match count";
  180.                 goto error;
  181.                 }
  182.             }
  183.             offset += count*size;
  184.             break;
  185.             
  186.             case 'x':
  187.             if (count == BINARY_ALL) {
  188.                 errorString = "cannot use \"*\" in format string with \"x\"";
  189.                 goto error;
  190.             } else if (count == BINARY_NOCOUNT) {
  191.                 count = 1;
  192.             }
  193.             offset += count;
  194.             break;
  195.             case 'X':
  196.             if (count == BINARY_NOCOUNT) {
  197.                 count = 1;
  198.             }
  199.             if ((count > offset) || (count == BINARY_ALL)) {
  200.                 count = offset;
  201.             }
  202.             if (offset > length) {
  203.                 length = offset;
  204.             }
  205.             offset -= count;
  206.             break;
  207.             case '@':
  208.             if (offset > length) {
  209.                 length = offset;
  210.             }
  211.             if (count == BINARY_ALL) {
  212.                 offset = length;
  213.             } else if (count == BINARY_NOCOUNT) {
  214.                 goto badCount;
  215.             } else {
  216.                 offset = count;
  217.             }
  218.             break;
  219.             default: {
  220.             char buf[2];
  221.             
  222.             Tcl_ResetResult(interp);
  223.             buf[0] = cmd;
  224.             buf[1] = '\0';
  225.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  226.                 "bad field specifier \"", buf, "\"", NULL);
  227.             return TCL_ERROR;
  228.             }
  229.         }
  230.         }
  231.         if (offset > length) {
  232.         length = offset;
  233.         }
  234.         if (length == 0) {
  235.         return TCL_OK;
  236.         }
  237.  
  238.         /*
  239.          * Prepare the result object by preallocating the caclulated
  240.          * number of bytes and filling with nulls.
  241.          */
  242.  
  243.         resultPtr = Tcl_GetObjResult(interp);
  244.         Tcl_SetObjLength(resultPtr, length);
  245.         buffer = Tcl_GetStringFromObj(resultPtr, NULL);
  246.         memset(buffer, 0, (size_t) length);
  247.  
  248.         /*
  249.          * Pack the data into the result object.  Note that we can skip
  250.          * the error checking during this pass, since we have already
  251.          * parsed the string once.
  252.          */
  253.  
  254.         arg = 3;
  255.         format = Tcl_GetStringFromObj(objv[2], NULL);
  256.         cursor = buffer;
  257.         maxPos = cursor;
  258.         while (*format != 0) {
  259.         if (!GetFormatSpec(&format, &cmd, &count)) {
  260.             break;
  261.         }
  262.         if ((count == 0) && (cmd != '@')) {
  263.             arg++;
  264.             continue;
  265.         }
  266.         switch (cmd) {
  267.             case 'a':
  268.             case 'A': {
  269.             char pad = (char) (cmd == 'a' ? '\0' : ' ');
  270.  
  271.             str = Tcl_GetStringFromObj(objv[arg++], &length);
  272.  
  273.             if (count == BINARY_ALL) {
  274.                 count = length;
  275.             } else if (count == BINARY_NOCOUNT) {
  276.                 count = 1;
  277.             }
  278.             if (length >= count) {
  279.                 memcpy((VOID *) cursor, (VOID *) str,
  280.                     (size_t) count);
  281.             } else {
  282.                 memcpy((VOID *) cursor, (VOID *) str,
  283.                     (size_t) length);
  284.                 memset(cursor+length, pad,
  285.                         (size_t) (count - length));
  286.             }
  287.             cursor += count;
  288.             break;
  289.             }
  290.             case 'b':
  291.             case 'B': {
  292.             char *last;
  293.             
  294.             str = Tcl_GetStringFromObj(objv[arg++], &length);
  295.             if (count == BINARY_ALL) {
  296.                 count = length;
  297.             } else if (count == BINARY_NOCOUNT) {
  298.                 count = 1;
  299.             }
  300.             last = cursor + ((count + 7) / 8);
  301.             if (count > length) {
  302.                 count = length;
  303.             }
  304.             value = 0;
  305.             errorString = "binary";
  306.             if (cmd == 'B') {
  307.                 for (offset = 0; offset < count; offset++) {
  308.                 value <<= 1;
  309.                 if (str[offset] == '1') {
  310.                     value |= 1;
  311.                 } else if (str[offset] != '0') {
  312.                     errorValue = str;
  313.                     goto badValue;
  314.                 }
  315.                 if (((offset + 1) % 8) == 0) {
  316.                     *cursor++ = (char)(value & 0xff);
  317.                     value = 0;
  318.                 }
  319.                 }
  320.             } else {
  321.                 for (offset = 0; offset < count; offset++) {
  322.                 value >>= 1;
  323.                 if (str[offset] == '1') {
  324.                     value |= 128;
  325.                 } else if (str[offset] != '0') {
  326.                     errorValue = str;
  327.                     goto badValue;
  328.                 }
  329.                 if (!((offset + 1) % 8)) {
  330.                     *cursor++ = (char)(value & 0xff);
  331.                     value = 0;
  332.                 }
  333.                 }
  334.             }
  335.             if ((offset % 8) != 0) {
  336.                 if (cmd == 'B') {
  337.                 value <<= 8 - (offset % 8);
  338.                 } else {
  339.                 value >>= 8 - (offset % 8);
  340.                 }
  341.                 *cursor++ = (char)(value & 0xff);
  342.             }
  343.             while (cursor < last) {
  344.                 *cursor++ = '\0';
  345.             }
  346.             break;
  347.             }
  348.             case 'h':
  349.             case 'H': {
  350.             char *last;
  351.             int c;
  352.             
  353.             str = Tcl_GetStringFromObj(objv[arg++], &length);
  354.             if (count == BINARY_ALL) {
  355.                 count = length;
  356.             } else if (count == BINARY_NOCOUNT) {
  357.                 count = 1;
  358.             }
  359.             last = cursor + ((count + 1) / 2);
  360.             if (count > length) {
  361.                 count = length;
  362.             }
  363.             value = 0;
  364.             errorString = "hexadecimal";
  365.             if (cmd == 'H') {
  366.                 for (offset = 0; offset < count; offset++) {
  367.                 value <<= 4;
  368.                 c = tolower(((unsigned char *) str)[offset]);
  369.                 if ((c >= 'a') && (c <= 'f')) {
  370.                     value |= ((c - 'a' + 10) & 0xf);
  371.                 } else if ((c >= '0') && (c <= '9')) {
  372.                     value |= (c - '0') & 0xf;
  373.                 } else {
  374.                     errorValue = str;
  375.                     goto badValue;
  376.                 }
  377.                 if (offset % 2) {
  378.                     *cursor++ = (char) value;
  379.                     value = 0;
  380.                 }
  381.                 }
  382.             } else {
  383.                 for (offset = 0; offset < count; offset++) {
  384.                 value >>= 4;
  385.                 c = tolower(((unsigned char *) str)[offset]);
  386.                 if ((c >= 'a') && (c <= 'f')) {
  387.                     value |= ((c - 'a' + 10) << 4) & 0xf0;
  388.                 } else if ((c >= '0') && (c <= '9')) {
  389.                     value |= ((c - '0') << 4) & 0xf0;
  390.                 } else {
  391.                     errorValue = str;
  392.                     goto badValue;
  393.                 }
  394.                 if (offset % 2) {
  395.                     *cursor++ = (char)(value & 0xff);
  396.                     value = 0;
  397.                 }
  398.                 }
  399.             }
  400.             if (offset % 2) {
  401.                 if (cmd == 'H') {
  402.                 value <<= 4;
  403.                 } else {
  404.                 value >>= 4;
  405.                 }
  406.                 *cursor++ = (char) value;
  407.             }
  408.  
  409.             while (cursor < last) {
  410.                 *cursor++ = '\0';
  411.             }
  412.             break;
  413.             }
  414.             case 'c':
  415.             case 's':
  416.             case 'S':
  417.             case 'i':
  418.             case 'I':
  419.             case 'd':
  420.             case 'f': {
  421.             int listc, i;
  422.             Tcl_Obj **listv;
  423.  
  424.             if (count == BINARY_NOCOUNT) {
  425.                 /*
  426.                  * Note that we are casting away the const-ness of
  427.                  * objv, but this is safe since we aren't going to
  428.                  * modify the array.
  429.                  */
  430.  
  431.                 listv = (Tcl_Obj**)(objv + arg);
  432.                 listc = 1;
  433.                 count = 1;
  434.             } else {
  435.                 Tcl_ListObjGetElements(interp, objv[arg],
  436.                     &listc, &listv);
  437.                 if (count == BINARY_ALL) {
  438.                 count = listc;
  439.                 }
  440.             }
  441.             arg++;
  442.             for (i = 0; i < count; i++) {
  443.                 if (FormatNumber(interp, cmd, listv[i], &cursor)
  444.                     != TCL_OK) {
  445.                 return TCL_ERROR;
  446.                 }
  447.             }
  448.             break;
  449.             }
  450.             case 'x':
  451.             if (count == BINARY_NOCOUNT) {
  452.                 count = 1;
  453.             }
  454.             memset(cursor, 0, (size_t) count);
  455.             cursor += count;
  456.             break;
  457.             case 'X':
  458.             if (cursor > maxPos) {
  459.                 maxPos = cursor;
  460.             }
  461.             if (count == BINARY_NOCOUNT) {
  462.                 count = 1;
  463.             }
  464.             if ((count == BINARY_ALL)
  465.                 || (count > (cursor - buffer))) {
  466.                 cursor = buffer;
  467.             } else {
  468.                 cursor -= count;
  469.             }
  470.             break;
  471.             case '@':
  472.             if (cursor > maxPos) {
  473.                 maxPos = cursor;
  474.             }
  475.             if (count == BINARY_ALL) {
  476.                 cursor = maxPos;
  477.             } else {
  478.                 cursor = buffer + count;
  479.             }
  480.             break;
  481.         }
  482.         }
  483.         break;
  484.     
  485.     case BinaryScan: {
  486.         int i;
  487.         Tcl_Obj *valuePtr, *elementPtr;
  488.  
  489.         if (objc < 4) {
  490.         Tcl_WrongNumArgs(interp, 2, objv,
  491.             "value formatString ?varName varName ...?");
  492.         return TCL_ERROR;
  493.         }
  494.         buffer = Tcl_GetStringFromObj(objv[2], &length);
  495.         format = Tcl_GetStringFromObj(objv[3], NULL);
  496.         cursor = buffer;
  497.         arg = 4;
  498.         offset = 0;
  499.         while (*format != 0) {
  500.         if (!GetFormatSpec(&format, &cmd, &count)) {
  501.             goto done;
  502.         }
  503.         switch (cmd) {
  504.             case 'a':
  505.             case 'A':
  506.             if (arg >= objc) {
  507.                 goto badIndex;
  508.             }
  509.             if (count == BINARY_ALL) {
  510.                 count = length - offset;
  511.             } else {
  512.                 if (count == BINARY_NOCOUNT) {
  513.                 count = 1;
  514.                 }
  515.                 if (count > (length - offset)) {
  516.                 goto done;
  517.                 }
  518.             }
  519.  
  520.             str = buffer + offset;
  521.             size = count;
  522.  
  523.             /*
  524.              * Trim trailing nulls and spaces, if necessary.
  525.              */
  526.  
  527.             if (cmd == 'A') {
  528.                 while (size > 0) {
  529.                 if (str[size-1] != '\0' && str[size-1] != ' ') {
  530.                     break;
  531.                 }
  532.                 size--;
  533.                 }
  534.             }
  535.             valuePtr = Tcl_NewStringObj(str, size);
  536.             resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
  537.                 valuePtr,
  538.                 TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
  539.             if (resultPtr == NULL) {
  540.                 Tcl_DecrRefCount(valuePtr);    /* unneeded */
  541.                 return TCL_ERROR;
  542.             }
  543.             offset += count;
  544.             break;
  545.             case 'b':
  546.             case 'B': {
  547.             char *dest;
  548.  
  549.             if (arg >= objc) {
  550.                 goto badIndex;
  551.             }
  552.             if (count == BINARY_ALL) {
  553.                 count = (length - offset)*8;
  554.             } else {
  555.                 if (count == BINARY_NOCOUNT) {
  556.                 count = 1;
  557.                 }
  558.                 if (count > (length - offset)*8) {
  559.                 goto done;
  560.                 }
  561.             }
  562.             str = buffer + offset;
  563.             valuePtr = Tcl_NewObj();
  564.             Tcl_SetObjLength(valuePtr, count);
  565.             dest = Tcl_GetStringFromObj(valuePtr, NULL);
  566.  
  567.             if (cmd == 'b') {
  568.                 for (i = 0; i < count; i++) {
  569.                 if (i % 8) {
  570.                     value >>= 1;
  571.                 } else {
  572.                     value = *str++;
  573.                 }
  574.                 *dest++ = (char) ((value & 1) ? '1' : '0');
  575.                 }
  576.             } else {
  577.                 for (i = 0; i < count; i++) {
  578.                 if (i % 8) {
  579.                     value <<= 1;
  580.                 } else {
  581.                     value = *str++;
  582.                 }
  583.                 *dest++ = (char) ((value & 0x80) ? '1' : '0');
  584.                 }
  585.             }
  586.             
  587.             resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
  588.                 valuePtr,
  589.                 TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
  590.             if (resultPtr == NULL) {
  591.                 Tcl_DecrRefCount(valuePtr);    /* unneeded */
  592.                 return TCL_ERROR;
  593.             }
  594.             offset += (count + 7 ) / 8;
  595.             break;
  596.             }
  597.             case 'h':
  598.             case 'H': {
  599.             char *dest;
  600.             int i;
  601.             static char hexdigit[] = "0123456789abcdef";
  602.  
  603.             if (arg >= objc) {
  604.                 goto badIndex;
  605.             }
  606.             if (count == BINARY_ALL) {
  607.                 count = (length - offset)*2;
  608.             } else {
  609.                 if (count == BINARY_NOCOUNT) {
  610.                 count = 1;
  611.                 }
  612.                 if (count > (length - offset)*2) {
  613.                 goto done;
  614.                 }
  615.             }
  616.             str = buffer + offset;
  617.             valuePtr = Tcl_NewObj();
  618.             Tcl_SetObjLength(valuePtr, count);
  619.             dest = Tcl_GetStringFromObj(valuePtr, NULL);
  620.  
  621.             if (cmd == 'h') {
  622.                 for (i = 0; i < count; i++) {
  623.                 if (i % 2) {
  624.                     value >>= 4;
  625.                 } else {
  626.                     value = *str++;
  627.                 }
  628.                 *dest++ = hexdigit[value & 0xf];
  629.                 }
  630.             } else {
  631.                 for (i = 0; i < count; i++) {
  632.                 if (i % 2) {
  633.                     value <<= 4;
  634.                 } else {
  635.                     value = *str++;
  636.                 }
  637.                 *dest++ = hexdigit[(value >> 4) & 0xf];
  638.                 }
  639.             }
  640.             
  641.             resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
  642.                 valuePtr,
  643.                 TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
  644.             if (resultPtr == NULL) {
  645.                 Tcl_DecrRefCount(valuePtr);    /* unneeded */
  646.                 return TCL_ERROR;
  647.             }
  648.             offset += (count + 1) / 2;
  649.             break;
  650.             }
  651.             case 'c':
  652.             size = 1;
  653.             goto scanNumber;
  654.             case 's':
  655.             case 'S':
  656.             size = 2;
  657.             goto scanNumber;
  658.             case 'i':
  659.             case 'I':
  660.             size = 4;
  661.             goto scanNumber;
  662.             case 'f':
  663.             size = sizeof(float);
  664.             goto scanNumber;
  665.             case 'd':
  666.             size = sizeof(double);
  667.             /* fall through */
  668.             scanNumber:
  669.             if (arg >= objc) {
  670.                 goto badIndex;
  671.             }
  672.             if (count == BINARY_NOCOUNT) {
  673.                 if ((length - offset) < size) {
  674.                 goto done;
  675.                 }
  676.                 valuePtr = ScanNumber(buffer+offset, cmd);
  677.                 offset += size;
  678.             } else {
  679.                 if (count == BINARY_ALL) {
  680.                 count = (length - offset) / size;
  681.                 }
  682.                 if ((length - offset) < (count * size)) {
  683.                 goto done;
  684.                 }
  685.                 valuePtr = Tcl_NewObj();
  686.                 str = buffer+offset;
  687.                 for (i = 0; i < count; i++) {
  688.                 elementPtr = ScanNumber(str, cmd);
  689.                 str += size;
  690.                 Tcl_ListObjAppendElement(NULL, valuePtr,
  691.                     elementPtr);
  692.                 }
  693.                 offset += count*size;
  694.             }
  695.  
  696.             resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
  697.                 valuePtr,
  698.                 TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
  699.             if (resultPtr == NULL) {
  700.                 Tcl_DecrRefCount(valuePtr);    /* unneeded */
  701.                 return TCL_ERROR;
  702.             }
  703.             break;
  704.             case 'x':
  705.             if (count == BINARY_NOCOUNT) {
  706.                 count = 1;
  707.             }
  708.             if ((count == BINARY_ALL)
  709.                 || (count > (length - offset))) {
  710.                 offset = length;
  711.             } else {
  712.                 offset += count;
  713.             }
  714.             break;
  715.             case 'X':
  716.             if (count == BINARY_NOCOUNT) {
  717.                 count = 1;
  718.             }
  719.             if ((count == BINARY_ALL) || (count > offset)) {
  720.                 offset = 0;
  721.             } else {
  722.                 offset -= count;
  723.             }
  724.             break;
  725.             case '@':
  726.             if (count == BINARY_NOCOUNT) {
  727.                 goto badCount;
  728.             }
  729.             if ((count == BINARY_ALL) || (count > length)) {
  730.                 offset = length;
  731.             } else {
  732.                 offset = count;
  733.             }
  734.             break;
  735.             default: {
  736.             char buf[2];
  737.             
  738.             Tcl_ResetResult(interp);
  739.             buf[0] = cmd;
  740.             buf[1] = '\0';
  741.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  742.                 "bad field specifier \"", buf, "\"", NULL);
  743.             return TCL_ERROR;
  744.             }
  745.         }
  746.         }
  747.  
  748.         /*
  749.          * Set the result to the last position of the cursor.
  750.          */
  751.  
  752.         done:
  753.         Tcl_ResetResult(interp);
  754.         Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
  755.         break;
  756.     }
  757.     }
  758.     return TCL_OK;
  759.  
  760.     badValue:
  761.     Tcl_ResetResult(interp);
  762.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
  763.         " string but got \"", errorValue, "\" instead", NULL);
  764.     return TCL_ERROR;
  765.  
  766.     badCount:
  767.     errorString = "missing count for \"@\" field specifier";
  768.     goto error;
  769.  
  770.     badIndex:
  771.     errorString = "not enough arguments for all format specifiers";
  772.     goto error;
  773.  
  774.     error:
  775.     Tcl_ResetResult(interp);
  776.     Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1);
  777.     return TCL_ERROR;
  778. }
  779.  
  780. /*
  781.  *----------------------------------------------------------------------
  782.  *
  783.  * GetFormatSpec --
  784.  *
  785.  *    This function parses the format strings used in the binary
  786.  *    format and scan commands.
  787.  *
  788.  * Results:
  789.  *    Moves the formatPtr to the start of the next command. Returns
  790.  *    the current command character and count in cmdPtr and countPtr.
  791.  *    The count is set to BINARY_ALL if the count character was '*'
  792.  *    or BINARY_NOCOUNT if no count was specified.  Returns 1 on
  793.  *    success, or 0 if the string did not have a format specifier.
  794.  *
  795.  * Side effects:
  796.  *    None.
  797.  *
  798.  *----------------------------------------------------------------------
  799.  */
  800.  
  801. static int
  802. GetFormatSpec(formatPtr, cmdPtr, countPtr)
  803.     char **formatPtr;        /* Pointer to format string. */
  804.     char *cmdPtr;        /* Pointer to location of command char. */
  805.     int *countPtr;        /* Pointer to repeat count value. */
  806. {
  807.     /*
  808.      * Skip any leading blanks.
  809.      */
  810.  
  811.     while (**formatPtr == ' ') {
  812.     (*formatPtr)++;
  813.     }
  814.  
  815.     /*
  816.      * The string was empty, except for whitespace, so fail.
  817.      */
  818.  
  819.     if (!(**formatPtr)) {
  820.     return 0;
  821.     }
  822.  
  823.     /*
  824.      * Extract the command character and any trailing digits or '*'.
  825.      */
  826.  
  827.     *cmdPtr = **formatPtr;
  828.     (*formatPtr)++;
  829.     if (**formatPtr == '*') {
  830.     (*formatPtr)++;
  831.     (*countPtr) = BINARY_ALL;
  832.     } else if (isdigit(**formatPtr)) {
  833.     (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
  834.     } else {
  835.     (*countPtr) = BINARY_NOCOUNT;
  836.     }
  837.     return 1;
  838. }
  839.  
  840. /*
  841.  *----------------------------------------------------------------------
  842.  *
  843.  * FormatNumber --
  844.  *
  845.  *    This routine is called by Tcl_BinaryObjCmd to format a number
  846.  *    into a location pointed at by cursor.
  847.  *
  848.  * Results:
  849.  *     A standard Tcl result.
  850.  *
  851.  * Side effects:
  852.  *    Moves the cursor to the next location to be written into.
  853.  *
  854.  *----------------------------------------------------------------------
  855.  */
  856.  
  857. static int
  858. FormatNumber(interp, type, src, cursorPtr)
  859.     Tcl_Interp *interp;        /* Current interpreter, used to report
  860.                  * errors. */
  861.     int type;            /* Type of number to format. */
  862.     Tcl_Obj *src;        /* Number to format. */
  863.     char **cursorPtr;        /* Pointer to index into destination buffer. */
  864. {
  865.     int value;
  866.     double dvalue;
  867.     char cmd = (char)type;
  868.  
  869.     if (cmd == 'd' || cmd == 'f') {
  870.     if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
  871.         return TCL_ERROR;
  872.     }
  873.     if (cmd == 'd') {
  874.         *((double *)(*cursorPtr)) = dvalue;
  875.         (*cursorPtr) += sizeof(double);
  876.     } else {
  877.         /*
  878.          * Because some compilers will generate floating point exceptions
  879.          * on an overflow cast (e.g. Borland), we restrict the values
  880.          * to the valid range for float.
  881.          */
  882.  
  883.         if (fabs(dvalue) > (double)FLT_MAX) {
  884.         *((float *)(*cursorPtr))
  885.             = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
  886.         } else if (fabs(dvalue) < (double)FLT_MIN) {
  887.         *((float *)(*cursorPtr)) = (float) 0.0;
  888.         } else {
  889.         *((float *)(*cursorPtr)) = (float) dvalue;
  890.         }
  891.         (*cursorPtr) += sizeof(float);
  892.     }
  893.     } else {
  894.     if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) {
  895.         return TCL_ERROR;
  896.     }
  897.     if (cmd == 'c') {
  898.         *(*cursorPtr)++ = (char)(value & 0xff);
  899.     } else if (cmd == 's') {
  900.         *(*cursorPtr)++ = (char)(value & 0xff);
  901.         *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
  902.     } else if (cmd == 'S') {
  903.         *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
  904.         *(*cursorPtr)++ = (char)(value & 0xff);
  905.     } else if (cmd == 'i') {
  906.         *(*cursorPtr)++ = (char)(value & 0xff);
  907.         *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
  908.         *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
  909.         *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
  910.     } else if (cmd == 'I') {
  911.         *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
  912.         *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
  913.         *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
  914.         *(*cursorPtr)++ = (char)(value & 0xff);
  915.     }
  916.     }
  917.     return TCL_OK;
  918. }
  919.  
  920. /*
  921.  *----------------------------------------------------------------------
  922.  *
  923.  * ScanNumber --
  924.  *
  925.  *    This routine is called by Tcl_BinaryObjCmd to scan a number
  926.  *    out of a buffer.
  927.  *
  928.  * Results:
  929.  *    Returns a newly created object containing the scanned number.
  930.  *    This object has a ref count of zero.
  931.  *
  932.  * Side effects:
  933.  *    None.
  934.  *
  935.  *----------------------------------------------------------------------
  936.  */
  937.  
  938. static Tcl_Obj *
  939. ScanNumber(buffer, type)
  940.     char *buffer;        /* Buffer to scan number from. */
  941.     int type;            /* Type of number to scan. */
  942. {
  943.     int c;
  944.  
  945.     switch ((char) type) {
  946.     case 'c':
  947.         /*
  948.          * Characters need special handling.  We want to produce a
  949.          * signed result, but on some platforms (such as AIX) chars
  950.          * are unsigned.  To deal with this, check for a value that
  951.          * should be negative but isn't.
  952.          */
  953.  
  954.         c = buffer[0];
  955.         if (c > 127) {
  956.         c -= 256;
  957.         }
  958.         return Tcl_NewIntObj(c);
  959.     case 's':
  960.         return Tcl_NewIntObj((short)(((unsigned char)buffer[0])
  961.             + ((unsigned char)buffer[1] << 8)));
  962.     case 'S':
  963.         return Tcl_NewIntObj((short)(((unsigned char)buffer[1])
  964.             + ((unsigned char)buffer[0] << 8)));
  965.     case 'i':
  966.         return Tcl_NewIntObj((long) (((unsigned char)buffer[0])
  967.             + ((unsigned char)buffer[1] << 8)
  968.             + ((unsigned char)buffer[2] << 16)
  969.             + ((unsigned char)buffer[3] << 24)));
  970.     case 'I':
  971.         return Tcl_NewIntObj((long) (((unsigned char)buffer[3])
  972.             + ((unsigned char)buffer[2] << 8)
  973.             + ((unsigned char)buffer[1] << 16)
  974.             + ((unsigned char)buffer[0] << 24)));
  975.     case 'f':
  976.         return Tcl_NewDoubleObj(*(float*)buffer);
  977.     case 'd':
  978.         return Tcl_NewDoubleObj(*(double*)buffer);
  979.     }
  980.     return NULL;
  981. }
  982.